home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
PowerLisp 2.01
/
PowerLisp 2.01 ƒ
/
Library
/
structures.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-05-22
|
5KB
|
210 lines
;;;
;;; PowerLisp 2.0
;;; Copyright © 1996 Roger Corman. All rights reserved.
;;; PowerLisp Structure facility.
;;;
(provide :structures)
(in-package :common-lisp)
(defmacro defstruct (name-and-options &rest doc-and-slots)
(let ( name
options
doc-string
slot-descriptors
struct-template
constructor-name
(boa-constructor-info nil)
(conc-name nil)
copier-name
predicate-name
accessor-name
(print-function nil)
setter-name
(slot-number 0)
(expressions nil))
(if (symbolp name-and-options)
(setq name name-and-options)
(progn
(if (or (not (consp name-and-options)) (not (symbolp (car name-and-options))))
(error "Invalid syntax for defstruct name: ~A" name-and-options))
(setq name (car name-and-options))
(setq options (cdr name-and-options))))
(setq conc-name (concatenate 'string (symbol-name name) "-"))
(dolist (opt options)
(cond
((keywordp opt))
((and (listp opt) (keywordp (car opt)))
(case (car opt)
(:conc-name
(if (cdr opt)
(setq conc-name
(if (cadr opt)
(symbol-name (cadr opt))
""))))
(:constructor
(if (cdr opt)
(if (cddr opt)
(setq boa-constructor-info (list (cadr opt) (caddr opt)))
(setq constructor-name (cadr opt)))))
(:copier (if (cdr opt) (setq copier-name (cadr opt))))
(:predicate (if (cdr opt) (setq predicate-name (cadr opt))))
(:include (error "defstruct option not implemented: ~A~%" (car opt)))
(:print-function (if (cdr opt) (setq print-function (cadr opt))))
(:type (error "defstruct option not implemented: ~A~%" (car opt)))
(:named t)
(:initial-offset t)
(otherwise (error "Unknown defstruct option: ~A~%" (car opt)))))
(t (error "Invalid defstruct option: ~A~%" opt))))
(if (stringp (car doc-and-slots))
(progn
(setq doc-string (car doc-and-slots))
(setq slot-descriptors (cdr doc-and-slots)))
(setq slot-descriptors doc-and-slots))
;; add the doc string with structure attribute
(if doc-string
(push
`(setf (documentation ',name 'structure) ,doc-string)
expressions))
;; process slot options
(push name struct-template)
(dolist (opt slot-descriptors)
(cond
((symbolp opt)
(push (intern (symbol-name opt) :keyword) struct-template)
(push nil struct-template))
((consp opt)
(let ((sym (car opt)))
(if (not (symbolp sym))
(error "Invalid slot descriptor: ~A~%" sym))
(push (intern (symbol-name sym) :keyword) struct-template)
(push (cadr opt) struct-template)))
(t (error "Invalid slot option: ~A~%" opt))))
;; install template
(push
`(setf (get ',name :struct-template)
(apply #'define-struct-template ',(reverse struct-template)))
expressions)
;; install print function
(if print-function
(push
`(setf (get ',name :struct-print)
',print-function)
expressions))
;; install constructor function
(setq constructor-name
(if constructor-name
(intern (symbol-name constructor-name))
(intern (concatenate 'string "MAKE-" (symbol-name name)))))
(push
`(setf (symbol-function ',constructor-name)
#'(lambda (&rest args)
(_make-struct (get ',name :struct-template) args)))
expressions)
(push
`(setf (get ',name ':struct-constructor) ',constructor-name)
expressions)
;; install BOA constructor
(if boa-constructor-info
(let ((order-list (mapcar
#'(lambda (sym)
(intern (symbol-name sym) (find-package :keyword)))
(cadr boa-constructor-info))))
(push
`(setf (symbol-function ',(car boa-constructor-info))
#'(lambda (&rest args)
(_make-struct-boa (get ',name :struct-template)
',order-list args)))
expressions)))
;; install copier function
(setq copier-name
(if copier-name
(intern (symbol-name copier-name))
(intern (concatenate 'string "COPY-" (symbol-name name)))))
(push
`(setf (symbol-function ',copier-name)
#'(lambda (arg) (clone-struct arg)))
expressions)
;; install predicate function
(setq predicate-name
(if predicate-name
(intern (symbol-name predicate-name))
(intern (concatenate 'string (symbol-name name) "-P"))))
(push
`(setf (symbol-function ',predicate-name)
#'(lambda (arg) (_check-struct-type arg ',name)))
expressions)
;; install accessor functions
(dolist (slot slot-descriptors)
;; install accessor function for this slot
(setq accessor-name
(intern
(concatenate 'string conc-name
(symbol-name (if (symbolp slot) slot (car slot))))))
(push
`(setf (symbol-function ',accessor-name)
#'(lambda (arg) (get-struct-field arg ,slot-number)))
expressions)
(setq setter-name (intern (concatenate 'string "%SET-" (symbol-name accessor-name))))
(push
`(setf (symbol-function ',setter-name)
#'(lambda (value arg) (set-struct-field value arg ,slot-number)))
expressions)
(push `(defsetf ,accessor-name ,setter-name) expressions)
(setq slot-number (1+ slot-number)))
(push `',name expressions)
(cons 'progn (reverse expressions))))